Shareware Super Platinum 8

home *** CD-ROM | disk | FTP | other *** search

/ Shareware Super Platinum 8 / Shareware Super Platinum 8.iso / mac / PROGTOOL / LIB211.ZIP;1 / WINDOWS.PRG < prev next >

Wrap

Text File | 1993-11-22 | 65.0 KB | 1,678 lines

*----------------------------------------------------------------------- *-- Program...: WINDOWS.PRG *-- Programmer: Ken Mayer (CIS: 71333,1030) *-- Date......: 07/27/1993 *-- Notes.....: This original set of functions was published in the *-- JUNE, 1992 issue of Technotes for dBASE IV (Vol. 90). *-- The routines were created by Adam Menkes (Borland), *-- except for the ones added in (used by a couple of the *-- functions) that were written by Jay Parsons and others. *-- For a complete explanation on how these routines work, *-- you need to read the article in TechNotes. *-- Some of these routines inspired others in DIALOGS.PRG *-- and PROC.PRG. *----------------------------------------------------------------------- FUNCTION Alert *----------------------------------------------------------------------- *-- Programmer..: Adam L. Menkes (BORLAND TECHNICAL SUPPORT) *-- Date........: 06/01/1992 *-- Notes.......: This routine creates a popup on the screen with a *-- title and one line message, forcing the user to notice *-- the message. The user must use the mouse on the 'OK' *-- pad, press <Esc> or press <Enter> to move on in the *-- program that called this function. *-- Written for.: dBASE IV, 1.5 *-- Rev. History: 06/01/1992 - Original *-- 06/19/1992 - Modified to accept the <Enter> key by *-- Ken Mayer, also a bit better cleanup at the end *-- (releasing things from memory, and so on). *-- Calls.......: None *-- Called by...: Any *-- Usage.......: Alert("<cTitle>","<cMessage>") *-- Example.....: lX = Alert("Print Aborted","You pressed <ESC>") *-- Returns.....: Logical *-- Parameters..: cTitle = Title line *-- cMessage = One line message (up to 79 characters) *----------------------------------------------------------------------- parameters cTitle, cMessage private wWindow,nRow,nCol,mPad m->wWindow = WINDOW() && save current Window save screen to sTemp && save the screen activate screen m->nRow = iif(val(right(set("DISPLAY"),2)) = 43,18,8) && center from top to bottom (does not take VGA50 into account) m->nCol = 38 - (max(len(m->cTitle),len(m->cMessage))/2) && center left/rt m->nCol2 = max(len(m->cTitle),len(m->cMessage)) && right side? *-- clear out a section of the screen @m->nRow,m->nCol Clear to m->nRow+6,m->nCol+m->nCol2 *-- fill in a box @m->nRow,m->nCol Fill to m->nRow+6,m->nCol+m->nCol2+1 color n+ && grey *-- put a double line border around box @m->nRow,m->nCol to m->nRow+6,m->nCol+m->nCol2+1 double color bg+ *-- display title @m->nRow + 1,m->nCol + 1 + iif(len(m->cTitle) > len(m->cMessage),0,; (len(m->cMessage)-len(m->cTitle)) / 2) say m->cTitle color w+/n *-- display line @m->nRow + 2, m->nCol + 1 to m->nRow + 2, m->nCol + m->nCol2 color bg+ *-- display message @m->nRow + 3, m->nCol+1+iif(len(m->cTitle) > len(m->cMessage),; (len(m->cTitle)-len(m->cMessage)) / 2, 0) say m->cMessage ; color w+/n *-- define/display a very small menu (one pad) define menu mAlert define pad pPad1 of mAlert prompt " OK " at m->nRow +5,37 on selection pad pPad1 of mAlert deactivate menu *-- added by Ken to deal with <Enter> on key label ctrl-M keyboard "{27}" *-- start it up activate menu mAlert *-- deal with user 'input' m->mPad = pad() *-- restore environment, free up RAM by releasing things on key label ctrl-m restore screen from sTemp release screen sTemp release menu mAlert if "" # m->wWindow activate window &wWindow. endif RETURN .not. "" = m->mPad && not empty pad? *-- EoF: Alert() FUNCTION CheckBox *----------------------------------------------------------------------- *-- Programmer..: Adam L. Menkes (BORLAND TECHNICAL SUPPORT) *-- Date........: 06/01/1992 *-- Notes.......: This routine brings up a one-line message, allows the *-- user to click mouse/press <Space> on it, to change *-- status. Pressing <Enter>/<Esc> chooses the current *-- setting ... *-- Written for.: dBASE IV, 1.5 *-- Rev. History: 06/01/1992 -- Original Release *-- Calls.......: None *-- Called by...: Any *-- Usage.......: CheckBox(<lVar>,"<cTitle>",<m->nRow>,<nCol>,<nASCII>) *-- Example.....: lX = CheckBox(.t.,"OK as is?",9,10,4) *-- Returns.....: Logical *-- Parameters..: lVar = On or Off to start? (.t.=on, .f.=off) *-- cTitle = Title/Message *-- nRow = Row to place this *-- nCol = Column ... *-- nASCII = ascii character to use in box. (Optional) *-- Default is 251 (˚). Other suggestions *-- include: *-- 4 (diamond), 176 (∞), 177 (±), 178 (≤), *-- 219 (€), 249 (˘), 250 (˙), 254 (˛) *-- (Check out the ASCII chart in the language *-- reference) *----------------------------------------------------------------------- parameters lVar, cTitle, nRow, nCol, nASCII *-- if parameter is left blank, assign 251 (˚) m->nASCII = iif(pCount() = 5, m->nASCII, 251) define menu mCheck *-- loop until user does something, or presses <Esc> do while .t. *-- define the menu pad ... define pad pCheck1 of mCheck at m->nRow,m->nCol prompt; "["+iif(m->lVar,chr(m->nASCII)," ")+"] "+m->cTitle on selection pad pCheck1 of mCheck deactivate menu *-- when user presses <Enter> turn it all off ... (send <Esc> ...) on key label ctrl-m keyboard "{27}" *-- start 'er up activate menu mCheck *-- (<Esc> or <Enter>) if lastkey() = 27 exit endif m->lVar = .not. m->lVar && set to opposite of current setting enddo *-- reset environment/release things on key label ctrl-m release menu mCheck RETURN m->lVar *-- EoF: CheckBox() Function CheckBx1 *----------------------------------------------------------------------- *-- Programmer..: Adam L. Menkes (BORLAND TECHNICAL SUPPORT) *-- Date........: 06/01/1992 *-- Notes.......: This routine brings up a one-line message, allows the *-- user to click mouse/press <Space> on it, to change *-- status. Pressing <Enter>/<Esc> chooses the current *-- setting ... This one is different, in that it does *-- not use a menu to accomplish it's ends, but uses *-- instead a memvar, with @/GET/READ and a picture *-- using the multiple choice ("@M") function. *-- Written for.: dBASE IV, 1.5 *-- Rev. History: 06/01/1992 -- Original *-- Calls.......: None *-- Called by...: Any *-- Usage.......: CheckBx1(<lVar>,"<cTitle>",<m->nRow>,<nCol>) *-- Example.....: lX = CheckBx1(.t.,"OK as is?",9,10) *-- Returns.....: Logical *-- Parameters..: lVar = On or Off to start? (.t.=on, .f.=off) *-- cTitle = Title/Message *-- nRow = Row to place this *-- nCol = Column ... *----------------------------------------------------------------------- parameters lVar, cTitle, nRow, nCol *-- save parts of environment ... m->cFormat = set("FORMAT") set format to m->cCursor = set("CURSOR") set cursor off *-- define starting value of cVar ... *-- (this is ASCII 255, ˚, ASCII 255, if lVar = .t., 3 spaces *-- if lVar = .f.) m->cVar = iif(m->lVar,chr(255)+chr(251)+chr(255),space(3)) *-- display/get, using picture @m->nRow,m->nCol get m->cVar picture "@M ,ˇ˚ˇ" *-- this picture is: space, comma, chr(255), chr(251), chr(255). @m->nRow,m->nCol + 4 say m->cTitle READ *-- reset environment set format to &cFormat. set cursor &cCursor. RETURN .not. (m->cVar = chr(32)) && not a space *-- EoF: CheckBx1() FUNCTION DropDown *----------------------------------------------------------------------- *-- Programmer..: Adam L. Menkes (BORLAND TECHNICAL SUPPORT) *-- Date........: 06/01/1992 *-- Notes.......: This function performs a picklist of a different sort. *-- In order to use it, you will either use an ARRAY (one- *-- dim) or a field in a database. It holds a choice in a *-- 'holding area', allowing the user to leave it there, *-- and maybe to change it with another option in the *-- list. *-- *-- I recommend you display an on-screen message for this *-- one, because it's not real intuitive (at least not to *-- me). To bring up the list, click on the arrows, to *-- select an item, click on the item, or highlight and *-- press <enter>. To Change, click (or select) another *-- item. To choose the actual item you want, click on *-- the one NEXT to the arrows (or use the arrow keys *-- to select that menu pad, and press <Enter>). *-- Written for.: dBASE IV, 1.5 *-- Rev. History: 06/01/1992 -- Original *-- Calls.......: TEMPNAME() Function in WINDOWS.PRG *-- ARRAYROWS() Function in WINDOWS.PRG *-- ARRAYCOLS() Function in WINDOWS.PRG *-- FIELDNUM() Function in WINDOWS.PRG *-- Called by...: Any *-- Usage.......: DropDown("<cType>","<cName>",[<nRow>,[<nCol>,; *-- [<nSize>]]]) *-- Example.....: x=DropDown("F","Lastname",10,15,6) *-- *-- Here is a suggested use: *-- @5,10 get cName when calldrop() && function below *-- read *-- *-- do other stuff *-- FUNCTION CallDrop *-- *-- display message about how to use *-- @18,10 say "<Enter> or Click mouse on "+chr(23)+; *-- " to see list" *-- @19,10 say "<Enter> or Click mouse on name at top"+; *-- " to select" *-- *-- call it ... if using a FIELD in the database, *-- *-- you might want to use a temp var, and then *-- *-- REPLACE <field> WITH ... *-- cName = dropdown("F","NAME",6,10,5) *-- && call dropdown func. *-- *-- redisplay it and clean out the 'gets' from *-- *-- memory *-- @5,10 get cName *-- clear gets *-- keyboard chr(23) && move on to next field ... *-- RETURN .T. *-- Returns.....: Selected item *-- Parameters..: cType = 'F' = Field, 'A' = Array (1-Dimensional) *-- cName = Field or Array name *-- nRow = Coordinates to display menu *-- nCol = Same *-- nSize = Number of items to display below dropdown *-- box *----------------------------------------------------------------------- parameters cType, cName, nRow, nCol, nSize *-- If these optional parms are NOT passed, we need to set default *-- values ... m->nSize = iif(pcount() <= 4, 5, m->nSize) m->nCol = iif(pCount() <= 3,10, m->nCol) m->nRow = iif(pCount() <= 2, 5, m->nRow) *-- setup m->nMaxLen = 1 m->lNone = (set("BORDER") = "NONE") define menu mDropDown *-- if it's an array, we work here for setup ... if upper(m->cType) = "A" m->nCols = arraycols(m->cName) m->nRows = arrayrows(m->cName) *-- determine width of display, by scanning each element of *-- array and finding the largest ... m->nX = 1 do while m->nX <= m->nCols m->nMaxLen = Max(m->nMaxLen, len(&cName.[m->nX])) m->nX = m->nX + 1 enddo *-- here we're gonna define the popup part of it ... define popup pDropDown from m->nRow+iif(m->lNone,0,1),; m->nCol-iif(m->lNone,1,0) to m->nRow+m->nSize+; iif(m->lNone,1,2),m->nCol+m->nMaxLen+iif(m->lNone,0,1) *-- define the bars ... the loops have to be done seperate, *-- since the width must be determined before the bars are defined. m->nX = 1 do while m->nX <= m->nCols define bar m->nX of DropDown prompt &cName.[m->nX] m->nX = m->nX + 1 enddo else *-- process if it's a field here do case case type ("&cName.") = "C" && character calculate max(len(trim(&cName.))) to m->nMaxLen case type ("&cName.") $ "FN" && numeric (or floating) cAlias = alias() dbftemp = tempname("DBF") nNum = fieldnum(m->cName) copy structure extended to (dbfTemp) select select() use (dbftemp) exclusive nosave go nNum m->nMaxLen = field_Len use select (cAlias) case type ("&cName.") = "D" m->nMaxLen = iif(set("CENTURY") = "ON",10,8) case type ("&cName.") = "L" m->nMaxLen = 1 endcase define popup pDropdown from m->nRow + iif(m->lNone,0,1),; m->nCol-iif(m->lNone,1,0) to; m->nRow+m->nSize+iif(m->lNone,1,2),; m->nCol+m->nMaxLen+iif(m->lNone,0,1) prompt field &cName. endif *-- define the pad that activates this thing ... define pad pPad2 of mDropDown prompt chr(23) at m->nRow,; m->nCol+m->nMaxLen on selection pad pPad2 of mDropDown activate popup pDropDown on selection popup pDropDown deactivate menu do while lastkey() # 27 m->xPrompt = trim(prompt())+space(m->nMaxLen - ; len(trim(prompt()))) define pad pPad1 of mDropDown prompt m->xPrompt at m->nRow,; m->nCol on selection pad pPad1 of mDropDown deactivate menu activate menu mDropDown pad pPad2 if pad() = "PPAD1" exit endif enddo release popup pDropDown release menu mDropDown RETURN trim(prompt()) *-- EoF: DropDown() FUNCTION MsWind *----------------------------------------------------------------------- *-- Programmer..: Adam L. Menkes (BORLAND TECHNICAL SUPPORT) *-- Date........: 06/01/1992 *-- Notes.......: This one creates a window that acts like one from *-- WINDOWS, in that you can move it, enlarge it to full- *-- screen, and bring it back to its original size. *-- Written for.: dBASE IV, 1.5 *-- Rev. History: 06/01/1992 -- Original *-- Calls.......: MOVEWINU Procedure in WINDOWS.PRG *-- MOVEWIND Procedure in WINDOWS.PRG *-- ENLARGE Procedure in WINDOWS.PRG *-- MSWINACT Procedure in WINDOWS.PRG *-- Called by...: Any *-- Usage.......: MsWind(<nTop>,<nLeft>,<nLower>,<nRight>) *-- Example.....: x=MsWind(5,10,20,70) *-- Returns.....: Logical *-- Parameters..: nTop = Top Row of window *-- nLeft = Left column *-- nBottom = Bottom Row of Window *-- nRight = Right column *----------------------------------------------------------------------- parameters nTop, nLeft, nLower, nRight *-- save environment save screen to sMSWIND m->lStatus = (set("STATUS") = "ON") m->lDisp43 = ("43" $ SET("DISPLAY")) *-- loop do while .t. restore screen from sMSWIND *-- define/redefine window area and box @m->nTop, m->nLeft clear to m->nLower, m->nRight @m->nTop, m->nLeft TO m->nLower, m->nRight *-- using menus to simulate Windows window ... define menu wNormal define pad pCabinet of wNormal prompt "["+chr(254)+"]"; at m->nTop, m->nLeft + 1 && ˛ define pad pMoveUp of wNormal prompt chr(18) ; at m->nTop, m->nRight - 4 && up/down-arrow define pad pEnlarge of wNormal prompt chr(30) ; at m->nTop, m->nRight - 1 && up-arrow-head define pad pMoveDn of wNormal prompt chr(18) ; at m->nLower, m->nRight - 4 && up/down arrow again *-- tell it what to do when an item is selected on selection pad pCabinet of wNormal deactivate menu on selection pad pMoveUp of wNormal do movewinu on selection pad pEnlarge of wNormal do enlarge on selection pad pMoveDn of wNormal do movewind *-- deal with changes ... do mswinact with m->nTop, m->nLeft activate menu wnormal *-- User pressed <Esc> or chose the 'close window' button/pad if lastkey() = 27 .or. "PCABINET" = pad() exit endif enddo && end of loop *-- restore environment restore screen from sMSWIND release screen sMSWIND release menu wNormal RETURN .not. "" = pad() *-- EoF: MSWind() PROCEDURE Enlarge *----------------------------------------------------------------------- *-- Programmer..: Adam L. Menkes (BORLAND TECHNICAL SUPPORT) *-- Date........: 06/01/1992 *-- Notes.......: Used in MSWIND() to 'enlarge' the window, and *-- redefine the menu ... *-- Written for.: dBASE IV, 1.5 *-- Rev. History: 06/01/1992 -- Original *-- Calls.......: MsWinAct Procedure in WINDOWS.PRG *-- Called by...: MsWind() Function in WINDOWS.PRG *-- Usage.......: Do Enlarge *-- Example.....: Do Enlarge *-- Returns.....: None *-- Parameters..: None *----------------------------------------------------------------------- *-- clear screen, draw border from upper left to a bottom *-- right corner ... clear @0,0 to iif(m->lStatus,21,24) + iif(m->lDisp43,18,0), 79 *-- define new version of menu define menu mEnlarge define pad pCabinet of mEnlarge prompt "["+chr(254)+"]" at 0,2 define pad pReduce of mEnlarge prompt chr(31) at 0,78 on selection pad pCabinet of mEnlarge deactivate menu on selection pad pReduce of mEnlarge deactivate menu *-- Routine to allow interaction inside menu window ... do mswinact with 0,0 *-- start 'er up activate menu mEnlarge deactivate menu if lastkey() = 27 keyboard "{27}" endif release menu mEnlarge clear RETURN *-- EoP: Enlarge PROCEDURE MoveWinU *----------------------------------------------------------------------- *-- Programmer..: Adam L. Menkes (BORLAND TECHNICAL SUPPORT) *-- Date........: 06/01/1992 *-- Notes.......: Used in MSWIND() to move the window up (unless the *-- window is at the top of the screen ...) *-- Written for.: dBASE IV, 1.5 *-- Rev. History: 06/01/1992 -- Original *-- Calls.......: None *-- Called by...: MsWind() Function in WINDOWS.PRG *-- Usage.......: Do MoveWinU *-- Example.....: Do MoveWinU *-- Returns.....: None *-- Parameters..: None *----------------------------------------------------------------------- *-- check for top of screen ... change coordinates m->nTop = m->nTop - iif(m->nTop = 0,0,1) m->nLower = m->nLower - iif(m->nTop = 0,0,1) deactivate menu RETURN *-- EoP: MoveWinU PROCEDURE MoveWinD *----------------------------------------------------------------------- *-- Programmer..: Adam L. Menkes (BORLAND TECHNICAL SUPPORT) *-- Date........: 06/01/1992 *-- Notes.......: Used in MSWIND() to move the window down (unless the *-- window is at the bottom of the screen ...) *-- Written for.: dBASE IV, 1.5 *-- Rev. History: 06/01/1992 -- Original *-- Calls.......: None *-- Called by...: MsWind() Function in WINDOWS.PRG *-- Usage.......: Do MoveWinD *-- Example.....: Do MoveWinD *-- Returns.....: None *-- Parameters..: None *----------------------------------------------------------------------- *-- check for bottom of screen/status line ... change coordinates m->nTop = m->nTop + iif(m->nLower = iif(m->lStatus,21,24)+; iif(m->lDisp43,18,0),0,1) m->nLower = m->nLower + iif(m->nLower=iif(m->lStatus,21,24)+; iif(m->lDisp43,18,0),0,1) deactivate menu RETURN *-- EoP: MoveWinD PROCEDURE MSWinAct *----------------------------------------------------------------------- *-- Programmer..: Adam L. Menkes (BORLAND TECHNICAL SUPPORT) *-- Date........: 06/01/1992 *-- Notes.......: Used in MSWIND() to move the actually display/ *-- redisplay information inside the window, even when a *-- window has been moved. This routine should be modified *-- for a specific system ... *-- Written for.: dBASE IV, 1.5 *-- Rev. History: 06/01/1992 -- Original *-- Calls.......: None *-- Called by...: MsWind() Function in WINDOWS.PRG *-- Usage.......: Do MSWinAct with <nTop>, <nLeft> *-- Example.....: Do MSWinAct with 5,10 *-- Returns.....: None *-- Parameters..: None *----------------------------------------------------------------------- parameters nTop, nLeft private nTop, nLeft @m->nTop + 2, m->nLeft + 2 say "This is line 1" @m->nTop + 3, m->nLeft + 2 say "And this is line 2" RETURN *-- EoP: MSWinAct FUNCTION RadioBut *----------------------------------------------------------------------- *-- Programmer..: Adam L. Menkes (BORLAND TECHNICAL SUPPORT) *-- Date........: 06/01/1992 *-- Notes.......: This is a Radio Button routine. NOTE that the array *-- called as cArray below must be a character array *-- (i.e., all data must be character data ...). *-- Written for.: dBASE IV, 1.5 *-- Rev. History: 06/01/1992 -- Original *-- Calls.......: ArrayRows() Function in WINDOWS.PRG *-- TmpRadio Procedure in WINDOWS.PRG *-- Called by...: None *-- Usage.......: RadioBut("<cArray>",<nRow>,<nCol>,<nDefPad>,<nASCII>) *-- Example.....: nReturn = RadioBut("aTest",5,10,1,15) *-- Returns.....: Numeric (Array Index of item selected) *-- Parameters..: cArray = Name of Array (Character data) *-- nRow = Row for coordinates ... (start position) *-- nCol = Column for same *-- nDefPad = Default Pad number *-- nASCII = ASCII character to use as 'button'(Optional) *-- try: 4 (Diamond), 9 (Circle), 15 (splot), 42 (*), *-- 249 (˘), 251 (˚) or 254 (˛) ... *----------------------------------------------------------------------- parameters cArray, nRow, nCol, nDefPad, nASCII define menu mRadio public aTmpRadio, nARows, nPad *-- get number of items to display m->nARows = ArrayRows(m->cArray) *-- set character for 'button' m->nASCII = iif(PCOUNT() <= 4,4,m->nASCII) && default is a 'diamond' *-- start definitions ... m->cPad = iif(pcount() => 4 .and. m->nDefPad # 0,; ltrim(str(m->nDefPad)),"1") m->nCol = iif(pcount() <= 2,10,m->nCol) m->nRow = iif(pCount() <= 1,5,m->nRow) *-- here we get the largest item in the array ... m->nX = 1 m->nLongest = 1 do while m->nX <= m->nARows m->nLongest = max(m->nLongest,len(trim(&cArray.[m->nX]))) m->nX = m->nX + 1 enddo *-- define a temporary array ... declare aTmpRadio[m->nARows] on key label ctrl-m keyboard "{27}" && close down if <Enter> ... m->cX = "1" do while .t. *-- define menu pads do while val(m->cX) <= m->nARows define pad button&cX. of mRadio at m->nRow - 1 + val(m->cX),; m->nCol prompt "("+ iif(aTmpRadio[val(m->cX)] ; .or. m->cPad = m->cX,chr(m->nASCII)," ")+") "+; trim(&cArray.[val(m->cX)])+; space(m->nLongest-len(trim(&cArray.[val(m->cX)]))) on selection pad button&cX. of mRadio deactivate menu m->cX = ltrim(str(val(m->cX)+1)) enddo *-- start 'er up activate menu mRadio pad button&nPad. *-- if <Esc> (or <Enter>), we're done ... if lastkey() = 27 nPad = substr(pad(),7) exit else *-- if not, perform routine below to reset the temp array ... do TmpRadio endif enddo *-- cleanup on key label ctrl-m m->nY = 1 do while m->nY <= m->nARows .and. .not. aTmpRadio[m->nY] m->nY = m->nY + 1 enddo release aTmpRadio, nPad release menu mRadio RETURN iif(m->nY > m->nARows, 0, m->nY) *-- EoF: RadioBut() PROCEDURE TmpRadio *----------------------------------------------------------------------- *-- Programmer..: Adam L. Menkes (BORLAND TECHNICAL SUPPORT) *-- Date........: 06/01/1992 *-- Notes.......: Used to set/reset the temporary array aTmpRadio[] for *-- use in the RadioBut() function above. *-- Written for.: dBASE IV, 1.5 *-- Rev. History: 06/01/1992 -- Original *-- Calls.......: None *-- Called by...: RadioBut() Function in WINDOWS.PRG *-- Usage.......: Do TmpRadio *-- Example.....: Do TmpRadio *-- Returns.....: None *-- Parameters..: None *----------------------------------------------------------------------- m->nPad = substr(pad(),7) m->nY = 1 do while m->nY <= m->nARows aTmpRadio[m->nY] = .f. m->nY = m->nY + 1 enddo aTmpRadio[val(m->nPad)] = .t. m->cX = "1" RETURN *-- EoP: TmpRadio FUNCTION ScrolBar *----------------------------------------------------------------------- *-- Programmer..: Adam L. Menkes (BORLAND TECHNICAL SUPPORT) *-- Date........: 06/01/1992 *-- Notes.......: Performs a horizontal scroll-bar to find a record in a *-- database file. Note that this function assumes a *-- database is open. Not quite sure how I'd use this one *-- ... *-- Written for.: dBASE IV, 1.5 *-- Rev. History: 06/01/1992 -- Original *-- Calls.......: None *-- Called by...: None *-- Usage.......: ScrolBar(<nAtLine>) *-- Example.....: This example is from the text of Adam's article: *-- Add the following line to your program or FMT file: *-- *-- ON KEY LABEL F5 DO MoveRec *-- *-- Create a simple PROCEDURE or program with the *-- following: *-- *-- PROCEDURE MoveRec *-- on key label ctrl-M chr(27) && press <Enter> *-- x=scrolbar(20) && call function *-- on key label ctrl-M && reset CTRL-M key *-- RETURN *-- *-- Returns.....: .T. *-- Parameters..: nAtLine = Line of screen (ROW) to display scroll bar *-- at. *----------------------------------------------------------------------- parameters nAtLine m->nAtLine = iif(pCount() = 1, m->nAtLine, 20) m->nBreak = 76 m->cX = "1" m->nY = 1 m->nRecord = reccount() m->nZ = (m->nBreak/m->nRecord) - int(m->nBreak/m->nRecord) *-- once again, this is being done via a menu ... define menu mScrollBar define pad pPad0 of mScrollBar prompt chr(17) at m->nAtLine, 1 *-- if the first pad is selected, back up one record on selection pad pPad0 of mScrollBar skip iif(bof(),0,-1) *-- deal with location of the rest ... do while val(m->cX) <= m->nRecord if m->nRecord <= m->nBreak define pad pPad&cX. of mScrollBar ; prompt; space((m->nBreak/m->nRecord)+iif(m->nZ => 1, int(m->nZ),0)); at m->nAtLine, m->nY + 1 endif m->nY = m->nY + int(m->nBreak/m->nRecord)+iif(m->nZ => 1, ; int(m->nZ),0) if m->nZ => 1 m->nZ = m->nZ - int(m->nZ) endif m->nZ = m->nZ + (m->nBreak / m->nRecord) - ; int(m->nBreak/m->nRecord) on selection pad pPad&cX. of mScrollBar go val(substr(pad(),4)) m->cX = ltrim(str(val(m->cX) + 1)) enddo *-- define final pad define pad pPad&cX. of mScrollBar prompt chr(16) at m->nAtLine, ; m->nY + 1 on selection pad pPad&cX. of mScrollBar skip iif(eof(),0,1) *-- start 'er up ... activate menu mScrollBar RETURN .t. *-- EoF: ScrolBar() *----------------------------------------------------------------------- *-- This section is where I (Ken Mayer) attempted to modify/improve some *-- of Adam's routines ... I may or may not have been successful, *-- YOU decide ... <g> *----------------------------------------------------------------------- FUNCTION Alert2 *----------------------------------------------------------------------- *-- Programmer..: Adam L. Menkes (BORLAND TECHNICAL SUPPORT) *-- Date........: 11/09/1992 *-- Notes.......: This routine creates a popup on the screen with a *-- title and one line message, forcing the user to notice *-- the message. The user must use the mouse on the 'OK' *-- pad, press <Esc> or press <Enter> to move on in the *-- program that called this function. *-- Written for.: dBASE IV, 1.5 *-- Rev. History: 06/19/1992 -- Modified to accept the <Enter> key by *-- Ken Mayer. *-- 06/19/1992 -- Copied from Adam's original, uses a *-- window, shadow, and programmer defineable *-- colors. *-- 07/29/1992 -- Joey stepped in and made some *-- modifications that seem to have helped as well, *-- including dealing with the keyboard buffer. *-- 10/09/1992 -- minor change -- title is now same color *-- as the "pad". *-- 11/09/1992 -- Joey Carroll added some minor changes *-- for cosmetics, as well as keeping the colors *-- working properly. *-- Calls.......: SHADOW Procedure in PROC.PRG *-- CENTER Procedure in PROC.PRG *-- JUSTIFY() Function in WINDOWS.PRG *-- Called by...: Any *-- Usage.......: Alert2("<cTitle>","<cMessage>","<cColor>") *-- Example.....: lX = Alert2("Print Aborted","You pressed <ESC>",; *-- "rg+/r,w+/b,rg+/r") *-- Returns.....: Logical *-- Parameters..: cTitle = Title line *-- cMessage = One line message (up to 75 characters) *-- cColor = Colors: <window forg/back>,<pad> (and *-- title),<box> *----------------------------------------------------------------------- parameters cTitle, cMessage, cColor private wWindow,nRow,nCol,mPad,cTempCol m->wWindow = WINDOW() && save current Window save screen to sTemp && save the screen i=inkey() && clear out keyboard buffer *-- get window coordinates *-- this centers from top to bottom, depending on monitor setup ... m->nULRow = iif(val(right(set("DISPLAY"),2)) = 43,18,8) *-- add 6, so the Window is large enough ... m->nBRRow = m->nULRow + 6 *-- left column ... m->nULCol = 36 - (max(len(m->cTitle),len(m->cMessage))/2) && center left-right *-- right column ... m->nBRCol = m->nULCol + max(len(m->cTitle),len(m->cMessage))+4 && right side *-- Window width ... m->nWidth = m->nBRCol - m->nULCol - 1 *-- define window Define window wAlert from m->nULRow,m->nULCol to m->nBRRow,m->nBRCol; DOUBLE color &cColor. activate screen *-- display shadow do shadow with m->nULRow,m->nULCol,m->nBRRow,m->nBRCol *-- start 'er up ... activate window wAlert *-- display title m->cTempCol = colorbrk(m->cColor,2) if len(m->cTitle) < m->nWidth m->cTitle = justify(m->cTitle,m->nWidth,"C") if len(m->cTitle) < m->nWidth m->cTitle = m->cTitle + " " endif endif do center with 0,m->nWidth,m->cTempCol,m->cTitle *-- display line m->cTempCol = colorbrk(m->cColor,1) @1,0 say replicate(chr(196),m->nWidth) color &cTempCol. *-- display message do center with 2,m->nWidth,"",m->cMessage *-- define/display a very small menu (one pad) define menu mAlert define pad pPad1 of mAlert prompt "[OK]" at 4,(m->nWidth/2)-1 on selection pad pPad1 of mAlert deactivate menu *-- added by Ken to deal with <Enter> on key label ctrl-M keyboard "{27}" *-- start it up activate menu mAlert *-- deal with user 'input' m->mPad = pad() release window wAlert *-- restore environment, free up RAM by releasing things on key label ctrl-m restore screen from sTemp release screen sTemp release menu mAlert if "" # m->wWindow activate window &wWindow. endif RETURN .not. "" = m->mPad && not empty pad? *-- EoF: Alert2() FUNCTION MsWind2 *----------------------------------------------------------------------- *-- Programmer..: Adam L. Menkes (BORLAND TECHNICAL SUPPORT) *-- Date........: 06/23/1992 *-- Notes.......: This one creates a window that acts like one from *-- WINDOWS, in that you can move it, enlarge it to full- *-- screen, and bring it back to its original size. *-- NOTE: The Title is NOT displaying in the EXPANDED *-- Window. This is based on a KNOWN BUG, forwarded to *-- development. *-- Written for.: dBASE IV, 1.5 *-- Rev. History: 06/23/1992 -- Ken Mayer -- Attempts made to use a *-- 'real' window (a dBASE defined window), shadows, *-- colors, and make the window look more like a Microsoft *-- Windows Window. *-- Calls.......: MOVEWIN2 Procedure in WINDOWS.PRG *-- ENLARGE2 Procedure in WINDOWS.PRG *-- MSWINAC2 Procedure in WINDOWS.PRG *-- SHADOW Procedure in PROC.PRG *-- Called by...: Any *-- Usage.......: MsWind2(<nTop>,<nLeft>,<nLower>,<nRight>,"<cColor>",; *-- "<cTitle>") *-- Example.....: x=MsWind2(5,10,20,70,"rg+/gb,w+/b,rg+/gb",; *-- "This is a title") *-- Returns.....: Logical *-- Parameters..: nTop = Top Row of window *-- nLeft = Left column *-- nBottom = Bottom Row of Window *-- nRight = Right column *-- cColor = Color combinations to be used: *-- <Normal/Unselected pad>,<Selected pad>,<Box> *-- cTitle = Title for first line of window ... *-- NOTE: if the title is longer than can be *-- displayed with the buttons on the first *-- line, it will be truncated ... *----------------------------------------------------------------------- parameters nTop, nLeft, nLower, nRight, cColor, cTitle *-- save environment save screen to sMSWIND m->lStatus = (set("STATUS") = "ON") m->lDisp43 = ("43" $ SET("DISPLAY")) *-- loop do while .t. *-- bring back old screen before defining all this if window() = "WMSWIND" deactivate window wMSWIND endif restore screen from sMSWIND *-- define/redefine window area and box activate screen define window wMSWind from m->nTop,m->nLeft to ; m->nLower,m->nRight double color &cColor. do shadow with m->nTop,m->nLeft,m->nLower,m->nRight activate window wMSWind *-- deal with defining where to display the title (and truncating *-- if necessary) *-- define width and height of window m->nWidth = m->nRight - m->nLeft - 2 && account for border m->nHeight = m->nLower - m->nTop - 2 && ditto m->nWidth2 = m->nWidth - 9 && (space used by menu buttons) if len(trim(m->cTitle)) > (m->nWidth2 - 2) && leave room for a space on each sd m->cTitle2 = left(m->cTitle,m->nWidth2-2) else m->cTitle2 = trim(m->cTitle) endif m->nSpaces = m->nWidth2 - len(m->cTitle2) m->nSpaces1 = m->nSpaces/2 m->nSpaces2 = iif(m->nSpaces1=int(m->nSpaces/2),; m->nSpaces1,m->nSpaces1+1) m->cTitle2 = space(m->nSpaces1) + m->cTitle2 + space(m->nSpaces2) m->cTitlCol = colorbrk(m->cColor,2) @0,3 say m->cTitle2 color &cTitlCol. *-- using menus to simulate Windows window ... define menu wNormal define pad pCabinet of wNormal prompt "["+chr(254)+"]" at 0, 0 define pad pMoveUp of wNormal prompt "["+chr(24)+"]" at 0,; m->nWidth - 6 define pad pEnlarge of wNormal prompt "["+chr(30)+"]" at 0,; m->nWidth - 3 define pad pMoveDn of wNormal prompt "["+chr(25)+"]" ; at m->nHeight, m->nWidth - 3 define pad pMoveRt of wNormal prompt "["+chr(26)+"]" ; at m->nHeight, m->nWidth - 6 define pad pMoveLf of wNormal prompt "["+chr(27)+"]" ; at m->nHeight, m->nWidth - 9 *-- tell it what to do when an item is selected on selection pad pCabinet of wNormal deactivate menu on selection pad pMoveUp of wNormal do movewin with pad() on selection pad pEnlarge of wNormal do enlarge2 with m->cTitle,; m->cTitlCol on selection pad pMoveDn of wNormal do movewin with pad() on selection pad pMoveRt of wNormal do movewin with pad() on selection pad pMoveLf of wNormal do movewin with pad() *-- Display something in Window do mswinat2 *-- start the menu activate menu wnormal *-- User pressed <Esc> or chose the 'close window' button/pad if lastkey() = 27 .or. "PCABINET" = pad() exit endif enddo && end of loop *-- restore environment release window wMSWind restore screen from sMSWIND release screen sMSWIND release menu wNormal RETURN .not. "" = pad() *-- EoF: MSWind2() PROCEDURE Enlarge2 *----------------------------------------------------------------------- *-- Programmer..: Adam L. Menkes (BORLAND TECHNICAL SUPPORT) *-- Date........: 06/23/1992 *-- Notes.......: Used in MSWIND2() to 'enlarge' the a window, and *-- redfine the menu ... *-- Written for.: dBASE IV, 1.5 *-- Rev. History: 06/23/1992 -- Ken Mayer (CIS: 71333,1030) - redefined *-- to handle using real dBASE Windows ... *-- Calls.......: MsWinAt2 Procedure in WINDOWS.PRG *-- Called by...: MsWind2() Function in WINDOWS.PRG *-- Usage.......: Do Enlarge2 with cTitle, cTitlCol *-- Example.....: Do Enlarge2 with cTitle, cTitlCol *-- Returns.....: None *-- Parameters..: cTitle = Title from MSWIND2() *-- cTitlCol = Title color (also from MSWIND2()) *----------------------------------------------------------------------- parameters cTitle, cTitlCol *-- do a new version of the window ... deactivate window wMSWind restore screen from sMSWIND activate screen define window wMSWind from 0,0 to iif(m->lStatus,20,23) + ; iif(m->lDisp43,18,0), 77 double color &cColor. do shadow with 0,0,iif(lstatus,20,23)+iif(m->lDisp43,18,0),77 activate window wMSWind *-- deal with TITLE ... *-- deal with defining where to display the title (and truncating *-- if necessary) *-- define width and height of window m->nWidth = 74 && account for border m->nWidth2 = m->nWidth - 6 && (space used by menu buttons) if len(trim(m->cTitle)) > (m->nWidth2 - 2) && leave room for a space on each side m->cTitle2 = left(m->cTitle,m->nWidth2-2) else m->cTitle2 = trim(m->cTitle) endif m->nSpaces = m->nWidth2 - len(m->cTitle2) m->nSpaces1 = m->nSpaces/2 m->nSpaces2 = iif(m->nSpaces1=int(m->nSpaces/2),m->nSpaces1,; m->nSpaces1+1) m->cTitle2 = space(m->nSpaces1) + m->cTitle2 + space(m->nSpaces2) @0,3 say m->cTitle2 color &cTitlCol. *-- define new version of menu define menu mEnlarge define pad pCabinet of mEnlarge prompt "["+chr(254)+"]" at 0,0 define pad pReduce of mEnlarge prompt "["+chr(31)+"]" at 0,72 on selection pad pCabinet of mEnlarge deactivate menu on selection pad pReduce of mEnlarge deactivate menu *-- Routine to allow interaction inside menu window ... do mswinat2 *-- start 'er up activate menu mEnlarge if lastkey() = 27 keyboard "{27}" endif deactivate menu release window wMSWIND release menu mEnlarge RETURN *-- EoP: Enlarge2 PROCEDURE MoveWin *----------------------------------------------------------------------- *-- Programmer..: Ken Mayer (CIS: 71333,1030) *-- Date........: 06/23/1992 *-- Notes.......: Used in MSWIND() to move the window up (unless the *-- window is at the top of the screen ...) *-- Written for.: dBASE IV, 1.5 *-- Rev. History: 06/23/1992 -- Original *-- Calls.......: None *-- Called by...: MsWind() Function in WINDOWS.PRG *-- Usage.......: Do MoveWin with <pPad> *-- Example.....: Do MoveWin with pad() *-- Returns.....: None *-- Parameters..: pPad = menu pad selected to move window ... *----------------------------------------------------------------------- parameters pPad restore screen from sMSWIND do case case m->pPad = "PMOVEUP" *-- check for top of screen ... change coordinates m->nTop = m->nTop - iif(m->nTop = 0,0,1) m->nLower = m->nLower - iif(m->nTop = 0,0,1) case m->pPad = "PMOVEDN" m->nTop = m->nTop + iif(m->nLower = iif(m->lStatus,21,24)+; iif(m->lDisp43,18,0),0,1) m->nLower = m->nLower + iif(m->nLower=iif(m->lStatus,21,24)+; iif(m->lDisp43,18,0),0,1) case m->pPad = "PMOVELF" m->nLeft = m->nLeft - iif(m->nLeft = 0,0,1) m->nRight = m->nRight - iif(m->nLeft = 0,0,1) case m->pPad = "PMOVERT" m->nRight = m->nRight + iif(m->nRight = 79,0,1) m->nLeft = m->nLeft + iif(m->nRight = 79,0,1) endcase deactivate menu RETURN *-- EoP: MoveWin PROCEDURE MSWinAt2 *----------------------------------------------------------------------- *-- Programmer..: Adam L. Menkes (BORLAND TECHNICAL SUPPORT) *-- Date........: 06/23/1992 *-- Notes.......: Used in MSWIND2() to move the actually display/ *-- redisplay information inside the window, even when a *-- window has been moved. This routine should be *-- modified for a specific system ... This version *-- (for MSWIND2()) starts counting at the top + 1 -- *-- the first line (0) is for the menu and the title ... *-- Written for.: dBASE IV, 1.5 *-- Rev. History: 06/01/1992 -- Original *-- 06/23/1992 -- Modified by Ken Mayer to work with *-- MSWIND2(). *-- Calls.......: None *-- Called by...: MsWind2() Function in WINDOWS.PRG *-- Usage.......: Do MSWinAt2 *-- Example.....: Do MSWinAt2 *-- Returns.....: None *-- Parameters..: None *----------------------------------------------------------------------- @1,1 say "This is line 1" @2,1 say "And this is line 2" RETURN *-- EoP: MSWinAt2 FUNCTION Alert3 *----------------------------------------------------------------------- *-- Programmer..: Adam L. Menkes (SUPREME1) *-- Date........: 12/23/1992 *-- Notes.......: This function based on Alert2() *-- This routine creates a popup on the screen with a *-- title and one line message, forcing the user to notice *-- the message. The user must use the mouse on the 'OK' *-- pad, press <Esc> or press <Enter> to move on in the *-- program that called this function. *-- Written for.: dBASE IV, 1.5 *-- Rev. History: Original: 06/19/1992 *-- Alert2() *-- Modified to accept the <Enter> key by Ken Mayer. *-- 06/19/1992 -- Copied from Adam's original, uses a *-- window, shadow, and programmer defineable colors. *-- 07/29/1992 -- Joey stepped in and made some *-- modifications that seem to have helped as well, *-- including dealing with the keyboard buffer. *-- 10/09/1992 -- minor change -- title is now same color *-- as the "pad". *-- Alert22() *-- 11/12/1992 -- changed to look more like a Win 3.0/3.1 *-- window by printing a special 'line' below the title. *-- Also removed hard coding which forced border to *-- DOUBLE so that if called with border set to NONE, *-- gives even more Win-like appearance. Calls a new *-- function written for this technique, but can be used *-- in other programs. *-- 11/16/1992 -- modified to add cBORDER parameter ... *-- (K. Mayer) *-- 12/23/1992 -- tuned up centering of cTitle, cMessage, *-- and [OK] pad. Eliminated calls to Center.prg by *-- using Justify() along with @ say. (Joey Carroll) *-- Calls.......: SHADOW Procedure in PROC.PRG *-- JUSTIFY() Function in PROC.PRG *-- COLORBRK() Function in PROC.PRG *-- FBCLRBRK() Function in PROC.PRG *-- Called by...: Any *-- Usage.......: Alert2("<cTitle>","<cMessage>","<cColor>"[,; *-- "<cBorder>"]) *-- Example.....: ** if no border, I suggest colors which will contrast *-- with the active screen or window *-- lX = Alert2("Print Aborted","You pressed <ESC>",; *-- "rg+/r,w+/b,rg+/r","NONE") *-- Returns.....: Logical *-- Parameters..: cTitle = Title line *-- cMessage = One line message (up to 75 characters) *-- cColor = Colors: <window forg/back>,<pad> (and *-- title),<box> *-- cBorder = Border type (DOUBLE, SINGLE, NONE, PANEL) *-- optional -- will default to your setting *----------------------------------------------------------------------- parameters cTitle, cMessage, cColor, cBorder private wWindow,mPad,cTempCol,cColorF,cColorB,cColorAll private nWidth,nULRow,nULCol,nLRRow,nLRCol,cTitle2,cMessage2,nBorder m->cTitle2 = " " + ltrim(trim(m->cTitle)) + " " && don't jamb against walls m->cMessage2 = " " + ltrim(trim(m->cMessage)) + " " && don't jamb against walls wWindow = WINDOW() && save current Window save screen to sTemp && save the screen activate screen m->cDummyKey = inkey() && clear out keyboard buffer m->cOldBorder = set("BORDER") && get old border setting if .not. type("M->CBORDER") = "L" && if user set border ... set border to &cBorder. && start NEW border setting endif m->nBorder = iif(set("BORDER") = "NONE",0,2) && border factor *-- get window coordinates *-- this centers from top to bottom, depending on monitor setup ... m->nULRow = iif(val(right(set("DISPLAY"),2)) = 43,18,8) *-- add rows, number depends on border, so the Window is large *-- enough ... m->nBRRow = m->nULRow + 5 +m->nBorder *-- left column ... m->nULCol = 40 - (max(len(m->cTitle2),len(m->cMessage2))/2) && center left-right *-- right column ... m->nBRCol = m->nULCol + max(len(m->cTitle2),len(m->cMessage2)); + (m->nBorder - 1) *-- Window width ... m->nWidth = m->nBRCol - m->nULCol - 1 *-- define window Define window wAlert from m->nULRow,m->nULCol to m->nBRRow,m->nBRCol; color &cColor. *-- display shadow do shadow with m->nULRow,m->nULCol,m->nBRRow,m->nBRCol *-- start 'er up ... activate window wAlert *-- display a new type type line to look more like Win m->cTempCol = colorbrk(m->cColor,2) m->cColorF = FBClrBrk("B",m->cTempCol) && background of title bar text m->cColorB = FBClrBrk("B",colorbrk(m->cColor,1)) && foreground of 'normal' text m->cColorAll = m->cColorF + "/" + m->cColorB && color of 'special' line @ 0,0 say justify(m->cTitle2,m->nWidth +iif(m->nBorder = 0,4,2),"C"); color &cTempCol. && the Title Bar *-- chr(223) looks like this --> ﬂ <-- @ 1,0 say replicate(chr(223),m->nWidth + 2) color &cColorAll. && make thicker *-- display message @ 2,0 say justify(m->cMessage2,m->nWidth + ; iif(m->nBorder = 0,4,2),"C") *-- define/display a very small menu (one pad) define menu mAlert define pad pPad1 of mAlert prompt "[OK]" at 4,; ((m->nWidth-m->nBorder-2)/2) on selection pad pPad1 of mAlert deactivate menu *-- added by Ken to deal with <Enter> on key label ctrl-M keyboard "{27}" *-- start it up activate menu mAlert *-- deal with user 'input' m->mPad = pad() release window wAlert *-- restore environment, free up RAM by releasing things on key label ctrl-m restore screen from sTemp release screen sTemp release menu mAlert if "" # m->wWindow activate window &wWindow. endif set border to &cOldBorder. RETURN .not. "" = m->mPad && not empty pad? *-- EoF: Alert3() FUNCTION YesNo3 *----------------------------------------------------------------------- *-- Programmer..: Kenneth J. Mayer (CIS: 71333,1030) *-- Date........: 01/06/1993 *-- Notes.......: A version of the YESNO() routines in PROC.PRG, that *-- will handle a long (up to 254 character) message *-- string, is centered on the screen, and has a title *-- bar kind of like a Windows dialog box ... *-- Written for.: dBASE IV, 1.5 *-- Rev. History: 01/06/1993 -- Original *-- Calls.......: Center Procedure in PROC.PRG *-- Shadow Procedure in PROC.PRG *-- WordWrap Procedure in STRINGS.PRG *-- ColorBrk() Function in PROC.PRG *-- FBClrBrk() Function in PROC.PRG *-- Justify() Function in PROC.PRG *-- Called by...: Any *-- Usage.......: YesNo3(<lDefault>,<cTitle>,<cMessage>,<cColor>) *-- Example.....: if YesNo3(.t.,"Test",; *-- "This is a message of any length"+; *-- "up to 254 characters.",cWind1) *-- Returns.....: logical *-- Parameters..: lDefault = Logical value, for the default menu pad *-- (Yes/No) *-- cTitle = Title for title bar -- no longer than 30 *-- characters. *-- cMessage = Message - up to 254 characters in length. *-- cColor = "Standard" colors for window/menu/box *----------------------------------------------------------------------- parameters lDefault, cTitle, cMessage, cColor private nULRow, nULCol, nBRRow, nBRCol, nLMargin, nRMargin, lWrap *-- save it, so we can activate the screen and display a window on top *-- of whatever's there save screen to sYesNo *-- save window if there is one, and activate screen to be safe: m->wWindow = window() activate screen *-- now to define the coordinates ... m->nULCol = 20 && left side of box m->nBRCol = 60 && right side of box m->nWidth = 36 && width of dialog box ... 36 characters for text m->nHeight = int(len(m->cMessage)/m->nWidth) *-- if the remainder of the length of the message/width of box is > 0 *-- we have one more line of text ... m->nHeight = m->nHeight + iif(mod(len(m->cMessage),m->nWidth)>0,1,0) *-- deal with room for title, and menu at bottom m->nHeight = m->nHeight + 4 *-- row coordinates m->nULRow = (24-m->nHeight) / 2 && top row m->nBRRow = m->nULRow + m->nHeight + 1 *-- define the window define window wYesNo from m->nULRow,m->nULCol to m->nBRRow,m->nBRCol; double color &cColor. *-- now for the menu pads define menu mYesNo define pad pYes of mYesNo prompt "[Yes]" at m->nHeight - 1,10 define pad pNo of mYesNo prompt "[No]" at m->nHeight - 1,25 on selection pad pYes of mYesNo deactivate menu on selection pad pNo of mYesNo deactivate menu *-- display it do shadow with m->nULRow,m->nULCol,m->nBRRow,m->nBRCol activate window wYesNo *-- display title if len(m->cTitle) < m->nWidth m->cTitle = justify(m->cTitle,39,"C") if len(m->cTitle) < 39 m->cTitle = m->cTitle + " " endif endif m->cTempCol = colorbrk(m->cColor,2) m->cColorF = FBClrBrk("B",m->cTempCol) m->cColorB = FBClrBrk("B",colorbrk(m->cColor,1)) m->cColorAll = m->cColorF + "/" + m->cColorB @0,0 say m->cTitle color &cTempCol. @1,0 say replicate(chr(223),39) color &cColorAll. *-- display message do WordWrap with 2,2,m->cMessage,35 *-- set Y/N keys for menu pad clear typeahead && just to be safe on key label Y keyboard iif(pad() = "PYES","",chr(19))+chr(13) on key label N keyboard iif(pad() = "PNO", "",chr(4) )+chr(13) *-- activate the menu if m->lDefault activate menu mYesNo pad pYes else activate menu mYesNo pad pNo endif *-- reset system on key label Y on key label N release window wYesNo restore screen from sYesNo release screen sYesNo release menu mYesNo if .not. isblank(m->wWindow) activate window &wWindow. endif RETURN iif(pad() = "PYES",.t.,.f.) *-- EoF: YesNo3() *----------------------------------------------------------------------- *-- These functions are here so that we don't have to go hunting all *-- over *----------------------------------------------------------------------- FUNCTION TempName *----------------------------------------------------------------------- *-- Programmer..: Martin Leon (HMAN) Former Sysop, ATBBS *-- Date........: 05/27/1992 *-- Notes.......: Obtain a name for a temporary file of a given *-- extension that does not conflict with existing files. *-- Written for.: dBASE IV, v1.5 *-- Rev. History: Originally part of Makestru(), 6-12-1991 *-- 04/26/92, made a separate function - Jay Parsons *-- 05/27/92, added lDBTMP option - Bowen Moursund *-- Calls.......: None *-- Called by...: Any *-- Usage.......: TempName( cExt , lDBTMP ) *-- Example.....: Sortfile = TempName( "DBF" , .t. ) *-- Returns.....: Name not already in use. Additionally, if the memvar *-- cDBTMP is declared before calling the function with *-- the lDBTMP option, it will be assigned the result *-- of getenv("DBTMP"). *-- Parameters..: cExt = Extension to be given file ( without the ".") *-- lDBTMP = Optional. If .t., function returns unique *-- file name in the DBTMP subdirectory. *-- Side Effects: The function will return a unique filename for the *-- DEFAULT subdirectory if the lDBTMP option is used and *-- the DOS environment variable DBTMP does not point to *-- a valid subdirectory. *----------------------------------------------------------------------- parameters cExt, lDBTMP private all except cDBTMP m->cDefDir = set("DIRECTORY") if m->lDBTMP m->cDBTMP = getenv("DBTMP") if "" # m->cDBTMP set directory to &cDBTMP. endif endif do while .t. m->fName = "TMP" + ltrim( str( rand() * 100000, 5 ) ) if .not. file( m->fName + "." + m->cExt ) .and.; ( upper( m->cExt ) # "DBF" .or.; .not. ( file( m->fName + ".MDX" ) .or. file ; ( m->fName + ".DBT" ) ) ) exit endif enddo set directory to &cDefDir. RETURN m->fName *-- Eof() TempName FUNCTION ArrayRows *----------------------------------------------------------------------- *-- Programmer..: Jay Parsons (CIS: 72662,1302) *-- Date........: 03/01/1992 *-- Notes.......: Number of Rows in an array *-- Written for.: dBASE IV, 1.1 *-- Rev. History: 03/01/1992 -- Original *-- Calls.......: None *-- Called by...: Any *-- Usage.......: ArrayRows("<aArray>") *-- Example.....: n = ArrayRows("aTest") *-- Returns.....: numeric *-- Parameters..: aArray = Name of array *----------------------------------------------------------------------- parameters aArray private nHi, nLo, nTrial, nDims m->nLo = 1 m->nHi = 1170 if type( "&aArray.[ 1, 1 ]" ) = "U" m->nDims = 1 else m->nDims = 2 endif do while .T. m->nTrial = int( ( m->nHi + m->nLo ) / 2 ) if m->nHi < m->nLo exit endif if m->nDims = 1 .and. type( "&aArray.[ m->nTrial ]" ) = "U" .or. ; m->nDims = 2 .and. type( "&aArray.[ m->nTrial, 1 ]" ) = "U" m->nHi = m->nTrial - 1 else m->nLo = m->nTrial + 1 endif enddo RETURN m->nTrial *-- EoF: ArrayRows() FUNCTION ArrayCols *----------------------------------------------------------------------- *-- Programmer..: Jay Parsons (CIS: 72662,1302) *-- Date........: 03/01/1992 *-- Notes.......: Number of Columns in an array *-- Written for.: dBASE IV, 1.1 *-- Rev. History: 03/01/1992 -- Original *-- Calls.......: None *-- Called by...: Any *-- Usage.......: ArrayCols("<aArray>") *-- Example.....: n = ArrayCols("aTest") *-- Returns.....: numeric *-- Parameters..: aArray = Name of array *----------------------------------------------------------------------- parameters aArray private nHi, nLo, nTrial m->nLo = 1 m->nHi = 1170 if type( "&aArray.[ 1, 1 ]" ) = "U" RETURN 0 endif do while .t. m->nTrial = int( ( m->nHi + m->nLo ) / 2 ) if m->nHi < m->nLo exit endif if type( "&aArray.[ 1, m->nTrial ]" ) = "U" m->nHi = m->nTrial - 1 else m->nLo = m->nTrial + 1 endif enddo RETURN m->nTrial *-- EoF: ArrayCol() FUNCTION FieldNum *----------------------------------------------------------------------- *-- Programmer..: ? *-- Date........: 03/09/1992 *-- Notes.......: Designed to return the number of a given fieldname in *-- the database structure. Works on open database only. *-- Written for.: dBASE IV, 1.5 *-- Rev. History: 06/01/1992 -- Adam L. Menkes for 1.5 ... *-- Calls.......: None *-- Called by...: Any *-- Usage.......: FieldNum("<cFldName>") *-- Example.....: n = FieldNum("Firstname") *-- Returns.....: Numeric *-- Parameters..: cFldName = Name of Field *----------------------------------------------------------------------- Parameters cFldName m->cExact = set("EXACT") set exact on m->nField = 1 do while upper(m->cFldName) <> FIELD(m->nField) .and. ; m->nField <= fldcount() m->nField = m->nField + 1 enddo set exact &cExact. RETURN iif(len(trim(field(m->nField))) = 0,0,m->nField) *-- EoF: FieldNum() FUNCTION Justify *----------------------------------------------------------------------- *-- Programmer..: Roland Bouchereau (Ashton-Tate) *-- Date........: 12/23/1992 *-- Notes.......: Used to pad a field/string on the right, left or both, *-- justifying or centering it within the length *-- specified. If the length of the string passed is *-- greater than the size needed, the function will *-- truncate it. *-- Taken from Technotes, June 1990. Defaults to Left *-- Justify if invalid TYPE is passed ... *-- Written for.: dBASE IV, 1.0 *-- Rev. History: Original function 06/15/1991 *-- 12/17/1991 -- Modified into ONE function from three by *-- Ken Mayer, added a third parameter to handle that. *-- 12/23/1992 -- Modified by Joey Carroll to use STUFF() *-- instead of TRANSFORM(). *-- Calls.......: None *-- Called by...: Any *-- Usage.......: Justify(<cFld>,<nLength>,"<cType>") *-- Example.....: ?? Justify(Address,25,"R") *-- Returns.....: Padded/truncated field *-- Parameters..: cFld = Field/Memvar/Character String to justify *-- nLength = Width to justify within *-- cType = Type of justification: L=Left, C=Center, *-- R=Right *----------------------------------------------------------------------- parameters cFld,nLength,cType private cReturn m->cType = upper(m->cType) && just making sure ... if type("m->cFld")+type("m->nLength")+type("m->cType") $ "CNC,CFC" *-- set a picture function of 'X's, with @I,@J or @B function m->cReturn = space(m->nLength) m->cReturn = stuff(m->cReturn,; iif(m->cType = "C",(m->nLength-len(m->cFld))/2,; iif(m->cType = "R",m->nLength-len(m->cFld)+1,1)),; len(m->cFld),m->cFld) else m->cReturn = "" endif RETURN m->cReturn *-- EoF: Justify() PROCEDURE WordWrap *----------------------------------------------------------------------- *-- Programmer..: David Frankenbach (CIS: 72147,2635) *-- Date........: 01/14/1993 (Version 1.1) *-- Notes.......: Wraps a long string, breaking it into strings that *-- have a maximum length of nWidth. The first output is *-- displayed @nRow, nCol. Words are not split ... *-- Written for.: dBASE IV, 1.5 *-- Rev. History: 01/06/1993 -- Original Release (Version 1.0) *-- 01/14/1993 -- Version 1.1 -- Corrected side-effect of *-- destroying string arg, added test for *-- string[nWidth+1] = " " *-- Calls.......: None *-- Called by...: Any *-- Usage.......: do WordWrap with <nRow>, <nCol>, <cString>, <nWidth> *-- Example.....: do WordWrap with 2,2,cText,38 *-- Returns.....: None *-- Parameters..: nRow = Row to display first line at *-- nCol = Left side of area to display text at *-- cString = text to wrap *-- nWidth = Width of area to wrap text in *----------------------------------------------------------------------- parameters nRow, nCol, cString, nWidth private cTemp, nI, cStr m->cStr = m->cString && work with a COPY of input, to && avoid destroying original do while len(m->cStr) > 0 && while there's something to work on if (m->nWidth < len(m->cStr)) m->nI = m->nWidth && look for last " " in first nWidth if substr(m->cStr,m->nI+1,1) # " " do while ( (m->nI > 0) .and.; (substr(m->cStr,m->nI,1) # " ")) m->nI = m->nI - 1 enddo endif if m->nI = 0 && no spaces m->nI = m->nWidth && get first nWidth characters endif else m->nI = len(m->cStr) && use the rest of the string endif m->cTemp = left(m->cStr,m->nI) && get the part we're going to && display if m->nI < len(m->cStr) && remove that part m->cStr = ltrim(substr(m->cStr,m->nI + 1)) else m->cStr = "" endif *-- display it @m->nRow,m->nCol say m->cTemp *-- move to next row m->nRow = m->nRow + 1 enddo RETURN *-- EoP: WordWrap *----------------------------------------------------------------------- *-- End of Program: WINDOWS.PRG *-----------------------------------------------------------------------